home *** CD-ROM | disk | FTP | other *** search
/ CD Exchange / CD Exchange - Volume 1.iso / utils / misc / siod / scm / biblio.s < prev    next >
Encoding:
Text File  |  1993-10-02  |  13.8 KB  |  320 lines
  1.  
  2. (eval '(sequence
  3. (define data-corrente (read-number "data corrente:"))
  4. (define (biblio-loop)
  5.         (newline)
  6.         (display "Biblio -->")
  7.         (user-print (eval (read) user-biblio-environment)))
  8. (define user-biblio-environment (make-environment))
  9. (define (user-print exp)
  10.         (cond ((archivio? exp)
  11.                (let ((el ((get-arc exp) 'read (get-pos exp))))
  12.                     (cond ((eq? el 'out-of-range)
  13.                            (writeln "Archivio vuoto"))
  14.                           ((eq? (get-type exp) 'utente)
  15.                            (writeln "Catalogo " (get-sigla exp))
  16.                            (output-utente el))
  17.                           ((eq? (get-type exp) 'volume)
  18.                            (writeln "Schedario " (get-sigla exp))
  19.                            (output-volume el))
  20.                           (else (error "Archivio di tipo sconosciuto" exp)))))
  21.                (else (print exp))))
  22. (define (make-schedario size sigla)
  23.         (make-archivio size
  24.                        utente<=?
  25.                        utente=?
  26.                        (list 'utente sigla)))
  27. (define (make-catalogo size sigla)
  28.         (make-archivio size
  29.                        volume-autore<=?
  30.                        volume-autore=?
  31.                        (list 'volume sigla 0)))
  32. (define (crea)
  33.         (define tipo (begin (display "Tipo di archivio : ")
  34.                             (read)))
  35.         (define val (read-number "Dimensione archivio : "))
  36.         (define sigla (read-string "Codice archivio : "))
  37.         (cond ((eq? tipo 'utente)
  38.                (make-biblio (make-schedario val sigla) 0))
  39.               ((eq? tipo 'volume)
  40.                (make-biblio (make-catalogo val sigla) 0))
  41.               (else (error "Tipo di archivio sconosciuto." tipo))))
  42. (define (prossimo arc)
  43.         (if (< (get-pos arc) (-1+ ((get-arc arc) 'last-el nil)))
  44.             (begin (set-pos! arc (1+ (get-pos arc)))
  45.                    arc)
  46.             (begin (writeln "Ultimo elemento")
  47.                    arc)))
  48. (define (precedente arc)
  49.         (if (> (get-pos arc) 0)
  50.             (begin (set-pos! arc (-1+ (get-pos arc)))
  51.                    arc)
  52.             (begin (writeln "Primo elemento")
  53.                    arc)))
  54. (define (primo arc)
  55.         (set-pos! arc 0)
  56.         arc)
  57. (define (ultimo arc)
  58.         (set-pos! arc (-1+ ((get-arc arc) 'last-el nil)))
  59.         arc)
  60. (define (salva arc name)
  61.         ((get-arc arc) 'ch-us-da (get-data arc))
  62.         ((get-arc arc) 'save name))
  63. (define (carica name)
  64.         (define arc (make-archivio 0 nil nil nil))
  65.         (define res (arc 'load name))
  66.         (define tipo (car (arc 'us-data nil)))
  67.         (if (eq? res 'done)
  68.             (begin (cond ((eq? tipo 'utente)
  69.                           (arc 'ch-ord
  70.                              (cons utente<=? utente=?)))
  71.                          ((eq? tipo 'volume)
  72.                           (arc 'ch-ord
  73.                              (cons volume-autore<=? volume-autore=?)))
  74.                          (else (error "Archivio di tipo sconosciuto" arc)))
  75.                    (make-biblio arc 0))
  76.              (error "Errore durante l'apertura del file" res)))
  77.  
  78. (define (make-collocazione sigla pos)
  79.         (string-append sigla (integer->string pos 10)))
  80. (define (aggiungi arc)
  81.         (define tipo nil)
  82.         (define elem nil)
  83.         (if (not (archivio? arc))
  84.             (error "L'argomento di aggiungi deve essere un archivio" arc))
  85.         (set! tipo (get-type arc))
  86.         (cond ((eq? tipo 'utente)
  87.                (set! elem (input-utente)))
  88.               ((eq? tipo 'volume)
  89.                (set! elem (input-volume))
  90.                (set-collocazione-L! (get-libro-V elem)
  91.                                     (make-collocazione (get-sigla arc)
  92.                                                        (get-next-col arc)))
  93.                (set-next-col! arc (1+ (get-next-col arc))))
  94.               (else (error "Archivio sconosciuto" tipo)))
  95.         (if (conferma? "I dati sono corretti? ")
  96.             (if (eq? ((get-arc arc) 'add-ord elem) 'full)
  97.                 (writeln "Archivio pieno --- non aggiunto")))
  98.         arc)
  99. (define (cancella arc)
  100.         (if (not (archivio? arc))
  101.             (error "L'argomento di cancella deve essere un archivio" arc))
  102.         (user-print arc)
  103.         (if (conferma? "Vuoi cancellare questo elemento? ")
  104.             (if (eq? ((get-arc arc) 'del-el (get-pos arc)) 'done)
  105.                 (begin (if (and (>= (get-pos arc) ((get-arc arc) 'last-el nil))
  106.                                 (> (get-pos arc) 0))
  107.                        (set-pos! arc (-1+ (get-pos arc))))
  108.                        (writeln "Cancellato"))
  109.                 (writeln "Non posso cancellare")))
  110.         arc)
  111. (define (cataloga arc)
  112.         (define tipo nil)
  113.         (define archivio nil)
  114.         (if (not (archivio? arc))
  115.             (error "L'argomento di cataloga deve essere un archivio" arc))
  116.         (set! archivio (get-arc arc))
  117.         (set! tipo (get-type arc))
  118.         (do ((done #f)
  119.              (elem nil))
  120.             (done (writeln "Sto ordinando l'archivio")
  121.                   (archivio 'sort nil))
  122.             (writeln "Inserisci i dati")
  123.             (cond ((eq? tipo 'utente) (set! elem (input-utente)))
  124.                   ((eq? tipo 'volume) (set! elem (input-volume)))
  125.                   (else (error "Archivio di tipo sconosciuto" tipo)))
  126.             (if (conferma? "I dati sono corretti? ")
  127.                 (begin (if (eq? tipo 'volume)
  128.                            (begin (set-collocazione-L! (get-libro-V elem)
  129.                                        (make-collocazione (get-sigla arc)
  130.                                                         (get-next-col arc)))
  131.                                   (set-next-col! arc (1+ (get-next-col arc)))))
  132.                        (if (eq? (archivio 'add elem) 'full)
  133.                            (writeln "Archivio pieno -- non aggiunto"))))
  134.             (if (conferma? "Fine catalogazione? ")
  135.                 (set! done #t))))
  136. (define (cerca arc)
  137.         (define tipo nil)
  138.         (define found nil)
  139.         (if (not (archivio? arc))
  140.             (error "L'argomento di ricerca deve essere un archivio" arc))
  141.         (set! tipo (get-type arc))
  142.         (cond ((eq? tipo 'utente)
  143.                (set! found (cerca-utente (get-arc arc))))
  144.               ((eq? tipo 'volume)
  145.                (set! found (cerca-volume (get-arc arc))))
  146.               (else (error "Archivio sconosciuto" tipo)))
  147.         (if (number? found)
  148.  
  149.             (set-pos! arc found))
  150.         arc)
  151.  
  152. (define (cerca-utente archivio)
  153.         (do ((elem nil)
  154.              (found nil)
  155.              (done #f))
  156.             (done found)
  157.             (writeln "ricerca Utenti")
  158.             (set! elem (make-utente (input-persona) nil))
  159.             (set! found (archivio 'search elem))
  160.             (if (eq? found 'not-found)
  161.                 (writeln "Non trovato")
  162.                 (begin (set! elem (archivio 'read found))
  163.                        (writeln "Trovato:")
  164.                        (output-utente elem)
  165.                        (output-prestiti (get-prestiti-U elem))))
  166.             (if (conferma? "Fine ricerca? ")
  167.                 (set! done #t))))
  168.  
  169. (define (ric-seq arc pos elem)
  170.         (define el (arc 'read pos))
  171.         (cond ((eq? el 'out-of-range) nil)
  172.               ((volume=? elem el)
  173.                (cons el (ric-seq arc (1+ pos) elem)))
  174.               ((volume-autore<=? el elem) nil)
  175.               (else (ric-seq arc (1+ pos) elem))))
  176.  
  177. (define (cerca-volume archivio)
  178.         (do ((data nil)
  179.              (libro nil)
  180.              (elem nil)
  181.              (el-lis nil)
  182.              (found nil)
  183.              (done #f))
  184.             (done found)
  185.             (writeln "ricerca Volumi")
  186.             (set! libro (input-libro))
  187.             (set! data (read-number "Data:"))
  188.             (set! elem (make-volume libro data nil))
  189.             (set! found (archivio 'search elem))
  190.             (if (eq? found 'not-found)
  191.                 (writeln "Nessun volume con questi autori")
  192.                 (begin (writeln "Autori presenti nell'archivio.")
  193.                        (set! el-lis (ric-seq archivio found elem))
  194.                        (if (null? el-lis)
  195.                            (writeln "Nessun volume con questo titolo e data di pubblicazione")
  196.                            (begin (writeln "Trovate "(length el-lis) " copie del libro")
  197.                                   (for-each output-volume el-lis)))))
  198.             (if (conferma? "Fine ricerca? ")
  199.                 (set! done #t))))
  200.  
  201. (define (prestito volume utente)
  202.         (define vol nil)
  203.         (define ute nil)
  204.         (define da-re nil)
  205.         (if (or (not (archivio? volume))
  206.                 (not (eq? (get-type volume) 'volume)))
  207.             (error "Il primo argomento di prestito deve essere un archivio volumi" nil))
  208.         (if (or (not (archivio? utente))
  209.                 (not (eq? (get-type utente) 'utente)))
  210.             (error "Il secondo argomento di prestito deve essere un archivio utenti" nil))
  211.         (set! vol ((get-arc volume) 'read (get-pos volume)))
  212.         (set! ute ((get-arc utente) 'read (get-pos utente)))
  213.         (if (eq? ute 'out-of-range)
  214.             (writeln "Archivio utenti vuoto"))
  215.         (if (eq? vol 'out-of-range)
  216.             (writeln "Archivio volumi vuoto"))
  217.         (set! da-re (get-data-res-D (get-last-pres-V vol)))
  218.         (if (= (length (get-prestiti-U ute)) 3)
  219.             (error "L'utente ha gia` tre libri in prestito" nil))
  220.         (if (and (not (data? da-re)) da-re)
  221.             (error "Il volume e` gia` in prestito" nil))
  222.         (add-prestito-V! vol (make-data data-corrente (get-persona-U ute)))
  223.         (add-prestiti-U! (make-prestito (get-libro-V vol)
  224.                                         (make-data data-corrente nil))
  225.                          ute)
  226.         utente)
  227.  
  228. (define (restituzione volume utente)
  229.         (define vol nil)
  230.         (define ute nil)
  231.         (define prest nil)
  232.         (define pr-L nil)
  233.         (if (or (not (archivio? volume))
  234.                 (not (eq? (get-type volume) 'volume)))
  235.             (error "Il primo argomento di restituzione deve essere un archivio volumi" nil))
  236.         (if (or (not (archivio? utente))
  237.                 (not (eq? (get-type utente) 'utente)))
  238.             (error "Il secondo argomento di restituzione deve essere un archivio utenti" nil))
  239.         (set! vol ((get-arc volume) 'read (get-pos volume)))
  240.         (set! ute ((get-arc utente) 'read (get-pos utente)))
  241.         (if (eq? ute 'out-of-range)
  242.             (writeln "Archivio utenti vuoto"))
  243.         (if (eq? vol 'out-of-range)
  244.             (writeln "Archivio volumi vuoto"))
  245.         (get-collocazione-L (get-libro-V vol))
  246.         (set! prest (find-pres-U (get-collocazione-L (get-libro-V vol))
  247.                                  ute))
  248.         (if (null? prest)
  249.             (error "Il libro non e` in prestito a questo utente" utente))
  250.         (set! pr-L (get-pres-U prest ute))
  251.         (rem-pres-U! prest ute)
  252.         (set-data-res-D! (get-data-P pr-l) data-corrente)
  253.         (add-restituiti-U! pr-l ute)
  254.         (set-data-res-D! (get-last-pres-V vol) data-corrente)
  255.         utente)
  256. (define esci scheme-reset)
  257.  
  258. (define (stampa-archivio arc)
  259.         (define tipo nil)
  260.         (if (not (archivio? arc))
  261.             (error "L'argomento di stampa-archivio deve essere un archivio" arc))
  262.         (set! tipo (get-type arc))
  263.         (cond ((eq? tipo 'utente)
  264.                ((get-arc arc) 'for-each output-utente))
  265.               ((eq? tipo 'volume)
  266.                ((get-arc arc) 'for-each output-volume))
  267.               (else (error "Archivio sconosciuto" tipo))))
  268.  
  269. (define (stampa-prestiti-utente utente volume)
  270.         (define ut nil)
  271.         (if (or (not (archivio? utente))
  272.                 (not (eq? (get-type utente) 'utente)))
  273.             (error "Il primo argomento di stampa-prestiti-utente deve essere un archivio utenti" nil))
  274.         (if (or (not (archivio? volume))
  275.                 (not (eq? (get-type volume) 'volume)))
  276.             (error "Il secondo argomento di stampa-prestiti-utente deve essere un archivio volumi" nil))
  277.         (set! ut ((get-arc utente) 'read (get-pos utente)))
  278.         (writeln "Libri attualmente in prestito all'utente:")
  279.         (do ((prest (get-prestiti-U ut) (cdr prest))
  280.              (found nil))
  281.             ((null? prest))
  282.             (set! found
  283.                   ((get-arc volume) 'search
  284.                                     (make-volume (get-libro-P (car prest))
  285.                                                  nil
  286.                                                  nil)))
  287.             (if found
  288.                 (output-volume ((get-arc volume) 'read found))
  289.                 (output-libro (get-libro-P (car prest))))))
  290. (define (stampa-prestiti-volume volume data)
  291.         (if (or (not (archivio? volume))
  292.                 (not (eq? (get-type volume) 'volume)))
  293.             (error "Il primo argomento di stampa-prestiti-volume deve essere un archivio volumi" nil))
  294.         (if data
  295.         ((get-arc volume) 'for-each
  296.                           (lambda (x)
  297.                                   (define da-re (get-data-res-D (get-last-pres-V x)))
  298.                                   (if (and da-re (not (data? da-re)))
  299.                                       (if (and data
  300.                                                (data<=? (get-data-pre-D (get-last-pres-V x)) data))
  301.                                           (begin (output-volume x)
  302.                                                  (writeln "all'utente:")
  303.                                                  (output-persona da-re))))))
  304.         ((get-arc volume) 'for-each
  305.                           (lambda (x)
  306.                                   (define da-re (get-data-res-D (get-last-pres-V x)))
  307.                                   (if (and da-re (not (data? da-re)))
  308.                                           (begin (output-volume x)
  309.                                                  (writeln "all'utente:")
  310.                                                  (output-persona da-re)))))))
  311.  
  312.         ) biblioteca-environment)
  313.  
  314.  
  315.  
  316. (define (biblioteca)
  317.         (set! (fluid scheme-top-level)
  318.               (access biblio-loop biblioteca-environment))
  319.         (reset))
  320.